;;;   -*-LISP-*-
;;;   **************************************************************
;;;   ***** MACLISP ** CDMACS (Declarations and Macros for COMPLR) *
;;;   **************************************************************
;;;   ** (C) Copyright 1978 Massachusetts Institute of Technology **
;;;   ****** This is a Read-Only file! (All writes reserved) *******
;;;   **************************************************************





(EVAL-WHEN (COMPILE EVAL) 
(SETSYNTAX  '/# 
	    'MACRO 
	    '(LAMBDA () (COND ((= (TYIPEEK) 35.)
			       (TYI)				;Flush second #
			       (EVAL (READ)))
			      ('T ((LAMBDA (DATA EXLDL)
					   (AND (SETQ EXLDL (GET (CAR DATA) 'MACRO)) 
						(SETQ DATA (FUNCALL EXLDL DATA))) 
					   DATA) 
				   (READ) () )))))
(EOC-EVAL (SETSYNTAX '/# 'MACRO () )))


(SETQ CDMACSVERNO '##(COND ((CADDR (TRUENAME INFILE)))
			   ('/1)))


;;; Redefine DISPLACE into something harmless if making up a *PURE
;;;  version of the compiler in EXPR code

(DEFUN CDISPLACE MACRO (X) (CONS 'DISPLACE (CDR X)))
    
(EVAL-WHEN (EVAL) (REMPROP 'CDISPLACE 'MACRO) (DEFUN CDISPLACE (X Y) Y) )




(COMMENT DECLARATIONS FOR COMPLR ITSELF)

    
(DEFUN COMPDECLARE MACRO (L)
     (SPECIAL 
	ACSMODE ARGLOC ARGNO ARITHP ARRAYOPEN ASSEMBLE ATPL ATPL1 BVARS CAAGL
	CARCDR CDMACSVERNO CDUMP CFVFL CHOMPHOOK CL CLEANUPSPL CLOSED CLPROGN
	CMSGFILES CNT COBARRAY COMAL COMP COMPILATION-FLAGCONVERSION-TABLE
	COMPILER-STATE COMPLRVERNO CONDP CONDPNOB CONDTYPE CONDUNSF CREADTABLE
	CTAG DATA DISOWNED EFFS EOC-EVAL ERRFL EXIT EXITN EXLDL
	EXPAND-OUT-MACROS EXPR-HASH FASL FASLPUSH FBARP FILESCLOSEP FIXSW FLOSW
	FLPDL FXPDL GAG-ERRBREAKS GENPREFIX GFYC GL GOBRKL GOFOO GONE2 HLAC
	IMOSAR INFILE INITIALIZE INMLS INSTACK IOBARRAY KTYPE L-END-CNT
	LAP-INSIGNIF LAPLL LAPOF LDLST LERSTP+1 LINEL LMBP LOCVARS LOUT LOUT1
	LPASST-FXP LPASST-P+1 LPRSL MACROLIST MACROS MAKLAP-DEFAULTF-STYLE
	MAKUNBOUND MAPEX MAPSB MCX-TRACE MODELIST MSDEV MSDIR MUZZLED NLNVS
	NLNVTHTBP NOLAP NULFU NUMACS OLVRL ONMLS OPSYS OPVRL OUTFILES P1CCX
	P1CSQ P1GFY P1LL P1LLCEK P1LSQ P1PCX P1PSQ P1SPECIALIZEDVS P2P PKTYP
	PNOB PROGN PROGP PROGTYPE PROGUNSF PRSSL PVR PVRL QSM READ RECOMPL
	REGACS REGPDL RNL ROSENCEK SAVED-ERRLIST SFLG SLOTX SOBARRAY SPECIAL
	SPECIALS SPECVARS SPLDLST SQUID SREADTABLE STATE STSL SWITCHLIST
	SWITCHTABLE SYMBOLS TAKENAC1 TOPFN TTYNOTES TYO UNDFUNS UNFASLCOMMENTS
	UNSFLST UREAD UWRITE VGO VGOL VL YESWARNTTY
      )  
     (*FEXPR 
	*EXPR *FEXPR *LEXPR ARRAY* CGOL EREAD EVAL-WHEN FIXNUM FLONUM 
	INITIALIZE MAKLAP NOTYPE SPECIAL UNSPECIAL
      )
     (FIXNUM 
	AC ARGNO BASE BESTCNT BESTLOC CNT HLAC IBASE I II 
	LINEL M N NARGS NLARG NOACS P1CNT RSTNO TAKENAC1 VALAC 
      )
     (FIXNUM 
	(COM-AREF) (CC0) (CLLOC) (COML1) (COMLC) (COMARRAY)  
	(CONVNUMLOC FIXNUM) (FRAC) (FRAC1) (FRAC5) (FRACB) 
	(FREENUMAC0) (FREENUMAC1) (FREENUMAC) (FREEREGAC) 
	(LOADINREGAC) (LOADINSOMENUMAC) (LOADINNUMAC NOTYPE FIXNUM) 
	(OUTFUNCALL) (P1TRESS) (ZTYI) 
      )
     (*EXPR CARCDR CC0 CLEANUPSPL COMP COMPLRVERNO MCX-TRACE NARGS  
	    P1GFY P1SPECIALIZEDVS SPECIALS UNSAFEP  
      )
     (*LEXPR PNAMECONC CDUMP)
     (APPLY 'ARRAY* (SUBST () () '((NOTYPE (BOLA 9 7) (STGET 10.) (CBA 16.)
					   (PVIA 3 17.) (A1S1A ? 4) 
					   (AC-ADDRS 11.) (PDL-ADDRS 3 193.)))))
     (FIXSW 'T) (CLOSED () ) (GENSYM 0)
     '(COMMENT COMPDECLARE))





(DEFUN FASLDECLARE MACRO (L)
       (SPECIAL 
	    ALLATOMS AMBIGSYMS ATOMINDEX BINCT CURRENTFN CURRENTFNSYMS DDTSYMP
	    DDTSYMS ENTRYNAMES EXPR FASLEVAL FASLPUSH FASLVERNO FILOC FSLFLD
	    IMOBFL IMOSAR IMOUSR LASTENTRY LDFNM LITCNT LITERALP LITERALS
	    LITLOC *LOC MAINSYMPDL MAKUNBOUND MESSIOC MSDIR SQUIDP SYMBOLSP 
	    SYMPDL UFFIL UNDEFSYMS UNFASLCOMMENTS UNFASLSIGNIF
	  )
       (*EXPR 
	    *DDTSYM ARGSINFO ATOMINDEX BLOBLENGTH BUFFERBIN COLLECTATOMS
	    FASLDEFSYM FASLDIFF FASLEVAL FASLINIT FASLMAIN FASLMINUS
	    FASLNEGLIS FASLPASS1 FASLPASS2 FASLPLUS FASLVERNO
	    INDENT-TO-INSTACK LAPCONST LISTOUT LREMPROP MAKEWORD MESOUT
	    MOBYSYMPOP MSOUT MUNGEABLE REMPROPL SUBMATCH
	)
       (FIXNUM  (BLOBLENGTH) (ATOMINDEX) (ARGSINFO)
		(RECLITCOUNT) FILOC *LOC LITLOC LITCNT BINCT)
       (ARRAY* (NOTYPE (LCA 16.) (BSAR 9.) (NUMBERTABLE 127.))
	       (FIXNUM (BTAR 9.) (BXAR 9.)))
       (MAPEX T)
       '(COMMENT FASLDECLARE))



(COMMENT MACRO DEFUNITIONS AND INLINEABLE EXPRS)

(DEFUN OUTFS MACRO (X) 
       (CDISPLACE X (CONS (COND ((NULL (CDDDDR X)) 'OUT3FIELDS)
				((NULL (CDR (CDDDDR X))) 'OUT4FIELDS)
				('T 'OUT5FIELDS))
			  (REVERSE (CDR X)))))


;;; DEFUN-ILE is a macro which expands into (DEFUN <FN> MACRO ...).
;;; It allows macro definitions to be written in a natural way, using
;;;    dummy parameters and a template.  Eventually, it will mean
;;;    "Inline-able Expr"

(DEFUN DEFUN-ILE MACRO (X)
   ((LAMBDA (ARGNAME MATCHOVER)
	    (SUBLIS (LIST (CONS 'name (CADR X)) 
			  (CONS 'arg ARGNAME)
			  (CONS 'subsl (FUNCALL MATCHOVER 
						 (CADDR X)
						 (LIST 'CDR ARGNAME)))
			  (CONS 'body (COND ((CDDDDR X)
					     (CONS 'PROGN (CDDDR X)))
					    ((CADDDR X)))))
		    (COND ((NULL (CADDR X)) 
			   '(DEFUN name MACRO (arg) 
			     (CDISPLACE arg 'body)))
			  ('(DEFUN name MACRO (arg) 
			     (CDISPLACE arg (SUBLIS (LIST . subsl)  'body)))))))
       (GENSYM)
       '(LAMBDA (PAT VL)
		(COND ((ATOM PAT)
		       (COND ((NULL PAT) () )
			     ((SYMBOLP PAT) (LIST 'CONS (LIST 'QUOTE PAT) VL))
			     ((ERROR PAT '|NON-BINDABLE ATOM -- DEFUN-ILE|))))
		      ('T (CONS (FUNCALL MATCHOVER (CAR PAT) (LIST 'CAR VL))
				(FUNCALL MATCHOVER (CDR PAT) (LIST 'CDR VL)))))) ))




  (DEFUN-ILE NCDR (l n) (NTHCDR n l))
  (DEFUN-ILE EQUIV (a1 a2) (COND (a1 a2) ((NULL a2))))
  (DEFUN-ILE /2↑N-P (n) (ZEROP (BOOLE 4 n (- n))))
  (DEFUN-ILE INVERSE-ASCII (char) (GETCHARN char 1))
  (DEFUN-ILE |Oh, FOO!| () (OUTPUT 'FOO))
  (DEFUN-ILE ITSP () (EQ OPSYS 'ITS))
  (DEFUN-ILE SAILP () (EQ OPSYS 'SAIL))
  (DEFUN-ILE DEC10P () (EQ OPSYS 'DEC10))
  (DEFUN-ILE DEC20P () (EQ OPSYS 'DEC20))


  (DEFUN-ILE BARF (item msg a1 a2) (MSOUT item 'msg 'BARF a1 a2))
  (DEFUN-ILE DBARF (item msg a1 a2) (MSOUT item 'msg 'DATA a1 a2))
  (DEFUN-ILE WARN (item msg a1 a2) (MSOUT item 'msg 'WARN a1 a2))
  (DEFUN-ILE PDERR (item msg) (MSOUT item 'msg 'ERRFL 4 6))

 
  (DEFUN-ILE KNOW-ALL-TYPES (a1)
	     (COND ((NULL a1) () )
		   ((MEMQ a1 '(FIXNUM FLONUM)))
		   ((NOT (MEMQ '() a1)))))

  (DEFUN-ILE INITIALSLOTS () 
		'((() () () () () )	;REGACS
		  (() () () )		;NUMACS 
		  (() () () )		;ACSMODE
		  ()			;REGPDL
		  ()			;FXPDL
		  ()			;FLPDL
		 ))


  (DEFUN-ILE ERL-SET () 
	     (OR (MEMBER '(COMPLRVERNO) (SETQ ERRLIST SAVED-ERRLIST))
		 (PUSH '(COMPLRVERNO) ERRLIST)))
  (DEFUN-ILE SETUP-CATCH-PDL-COUNTS () 
    (SETQ LERSTP+1 13. LPASST-P+1 6. LPASST-FXP 11.))

  (DEFUN-ILE CLEARALLACS () (CLEARACS0 'T))
  (DEFUN-ILE NO-DELAYED-SPLDS () (CSLD (SETQ CCSLD 'T) 'T ()))

  (DEFUN-ILE NACS () '5)
  (DEFUN-ILE NUMVALAC () '7)
  (DEFUN-ILE NUMNACS () '3)
  (DEFUN-ILE NACS+1 () '##(1+ (NACS)))
  (DEFUN-ILE MAX-NPUSH () '16.)
  (DEFUN-ILE MAX-0PUSH () '8)
  (DEFUN-ILE MAX-0*0PUSH () '8)

  (DEFUN-ILE FXP0 () '-2048.)	;2↑11. Bit implies REGPDL
  (DEFUN-ILE FLP0 () '-4096.)	;2↑12. Bit (with 2↑11. off) implies FXPDL

  (DEFUN-ILE NPDL-ADDRS () '192.)

  (DEFUN-ILE REGADP-N (n) (LESSP ##(FXP0) n ##(NUMVALAC)))
  (DEFUN-ILE REGACP (x) (AND (SIGNP G x) (< x ##(NUMVALAC))))	;Watch OUT! Arg is copied!
  (DEFUN-ILE REGACP-N (n) (LESSP 0 n ##(NUMVALAC)))
  (DEFUN-ILE REGPDLP-N (n) (LESSP ##(FXP0) n 1))
  (DEFUN-ILE REGPDLP (x) (AND (SIGNP LE x) (> x ##(FXP0))))	;Watch OUT! Arg is copied!

  (DEFUN-ILE PDLLOCP (x) (SIGNP LE x))
  (DEFUN-ILE PDLLOCP-N (n) (NOT (> n 0)))
  (DEFUN-ILE ACLOCP (x) (SIGNP G x))
  (DEFUN-ILE ACLOCP-N (n) (> n 0))

  (DEFUN-ILE NUMACP (x) (AND (SIGNP G x) (NOT (< x ##(NUMVALAC)))))	;Watch OUT! Arg is copied!
  (DEFUN-ILE NUMACP-N (n) (NOT (< n ##(NUMVALAC))))
  (DEFUN-ILE NUMPDLP (x) (AND (SIGNP LE x) (NOT (> x ##(FXP0)))))	;Watch OUT! Arg is copied!

  (DEFUN-ILE NUMPDLP-N (n) (NOT (> n ##(FXP0))))
  (DEFUN-ILE FLPDLP-N  (n) (NOT (> n ##(FLP0))))

  


  (DEFUN-ILE PDLAC (mode) 
	     (COND ((EQ mode 'FIXNUM) 'FXP)
		   ((NULL mode) 'P)
		   ('FLP)))
  (DEFUN-ILE PDLGET (mode)
	     (COND ((EQ mode 'FIXNUM) FXPDL)
		   ((NULL mode) REGPDL)
		   (FLPDL)))
  (DEFUN-ILE ACSGET (mode)  (COND (mode NUMACS) (REGACS)))
  (DEFUN-ILE ACSSLOT (n)
	     (COND ((= n ##(NUMVALAC)) NUMACS)
		   ((= n ##(1+ (NUMVALAC))) (CDR NUMACS))
		   ('T (CDDR NUMACS))))
  (DEFUN-ILE ACSMODESLOT (n)
	     (COND ((= n ##(NUMVALAC)) ACSMODE)
		   ((= n ##(1+ (NUMVALAC))) (CDR ACSMODE))
		   ('T (CDDR ACSMODE))))
  (DEFUN-ILE NACSGET (mode)
	      (COND ((NULL mode) ##(1+ (NACS)))
		    ('T ##(1+ (NUMNACS)))))



  (DEFUN-ILE ILOCREG (x acx) (ILOCMODE x acx '(() FIXNUM FLONUM)))
  (DEFUN-ILE ILOCNUM (x acx) (ILOCMODE x acx '(FIXNUM FLONUM)))
  (DEFUN-ILE ILOCF (x) (ILOCMODE x 'FRACF '(() FIXNUM FLONUM)))
  (DEFUN-ILE ILOCN (x) (ILOCMODE x 'ARGNO '(() FIXNUM FLONUM)))
  (DEFUN-ILE FREACB () (FREEREGAC 'FRACB))
  (DEFUN-ILE FREAC () (FREEREGAC 'FRAC))

ββββ